home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / sort.scm < prev    next >
Text File  |  1999-04-19  |  4KB  |  155 lines
  1. ;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
  2. ;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
  3. ;;;
  4. ;;; This code is in the public domain.
  5.  
  6. ;;; Updated: 11 June 1991
  7. ;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
  8. ;;; Updated: 19 June 1995
  9.  
  10. ;;; (sorted? sequence less?)
  11. ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
  12. ;;; such that for all 1 <= i <= m,
  13. ;;;    (not (less? (list-ref list i) (list-ref list (- i 1)))).
  14.  
  15. (define (sort:sorted? seq less?)
  16.     (cond
  17.     ((null? seq)
  18.         #t)
  19.     ((vector? seq)
  20.         (let ((n (vector-length seq)))
  21.         (if (<= n 1)
  22.             #t
  23.             (do ((i 1 (+ i 1)))
  24.             ((or (= i n)
  25.                  (less? (vector-ref seq i)
  26.                          (vector-ref seq (- i 1))))
  27.                 (= i n)) )) ))
  28.     (else
  29.         (let loop ((last (car seq)) (next (cdr seq)))
  30.         (or (null? next)
  31.             (and (not (less? (car next) last))
  32.              (loop (car next) (cdr next)) )) )) ))
  33.  
  34.  
  35. ;;; (merge a b less?)
  36. ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
  37. ;;; and returns a new list in which the elements of a and b have been stably
  38. ;;; interleaved so that (sorted? (merge a b less?) less?).
  39. ;;; Note:  this does _not_ accept vectors.  See below.
  40.  
  41. (define (sort:merge a b less?)
  42.     (cond
  43.     ((null? a) b)
  44.     ((null? b) a)
  45.     (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
  46.         ;; The loop handles the merging of non-empty lists.  It has
  47.         ;; been written this way to save testing and car/cdring.
  48.         (if (less? y x)
  49.         (if (null? b)
  50.             (cons y (cons x a))
  51.             (cons y (loop x a (car b) (cdr b)) ))
  52.         ;; x <= y
  53.         (if (null? a)
  54.             (cons x (cons y b))
  55.             (cons x (loop (car a) (cdr a) y b)) )) )) ))
  56.  
  57.  
  58. ;;; (merge! a b less?)
  59. ;;; takes two sorted lists a and b and smashes their cdr fields to form a
  60. ;;; single sorted list including the elements of both.
  61. ;;; Note:  this does _not_ accept vectors.
  62.  
  63. (define (sort:merge! a b less?)
  64.     (define (loop r a b)
  65.     (if (less? (car b) (car a))
  66.         (begin
  67.         (set-cdr! r b)
  68.         (if (null? (cdr b))
  69.             (set-cdr! b a)
  70.             (loop b a (cdr b)) ))
  71.         ;; (car a) <= (car b)
  72.         (begin
  73.         (set-cdr! r a)
  74.         (if (null? (cdr a))
  75.             (set-cdr! a b)
  76.             (loop a (cdr a) b)) )) )
  77.     (cond
  78.     ((null? a) b)
  79.     ((null? b) a)
  80.     ((less? (car b) (car a))
  81.         (if (null? (cdr b))
  82.         (set-cdr! b a)
  83.         (loop b a (cdr b)))
  84.         b)
  85.     (else ; (car a) <= (car b)
  86.         (if (null? (cdr a))
  87.         (set-cdr! a b)
  88.         (loop a (cdr a) b))
  89.         a)))
  90.  
  91.  
  92.  
  93. ;;; (sort! sequence less?)
  94. ;;; sorts the list or vector sequence destructively.  It uses a version
  95. ;;; of merge-sort invented, to the best of my knowledge, by David H. D.
  96. ;;; Warren, and first used in the DEC-10 Prolog system.  R. A. O'Keefe
  97. ;;; adapted it to work destructively in Scheme.
  98.  
  99. (define (sort:sort! seq less?)
  100.     (define (step n)
  101.     (cond
  102.         ((> n 2)
  103.         (let* ((j (quotient n 2))
  104.                (a (step j))
  105.                (k (- n j))
  106.                (b (step k)))
  107.             (sort:merge! a b less?)))
  108.         ((= n 2)
  109.         (let ((x (car seq))
  110.               (y (cadr seq))
  111.               (p seq))
  112.             (set! seq (cddr seq))
  113.             (if (less? y x) (begin
  114.             (set-car! p y)
  115.             (set-car! (cdr p) x)))
  116.             (set-cdr! (cdr p) '())
  117.             p))
  118.         ((= n 1)
  119.         (let ((p seq))
  120.             (set! seq (cdr seq))
  121.             (set-cdr! p '())
  122.             p))
  123.         (else
  124.         '()) ))
  125.     (if (vector? seq)
  126.     (let ((n (vector-length seq))
  127.           (vec seq))
  128.       (set! seq (vector->list seq))
  129.       (do ((p (step n) (cdr p))
  130.            (i 0 (+ i 1)))
  131.           ((null? p) vec)
  132.         (vector-set! vec i (car p)) ))
  133.     ;; otherwise, assume it is a list
  134.     (step (length seq)) ))
  135.  
  136. ;;; (sort sequence less?)
  137. ;;; sorts a vector or list non-destructively.  It does this by sorting a
  138. ;;; copy of the sequence.  My understanding is that the Standard says
  139. ;;; that the result of append is always "newly allocated" except for
  140. ;;; sharing structure with "the last argument", so (append x '()) ought
  141. ;;; to be a standard way of copying a list x.
  142.  
  143. (define (sort:sort seq less?)
  144.     (if (vector? seq)
  145.     (list->vector (sort:sort! (vector->list seq) less?))
  146.     (sort:sort! (append seq '()) less?)))
  147.  
  148. ;;; eof
  149.  
  150. (define sorted? sort:sorted?)
  151. (define merge sort:merge)
  152. (define merge! sort:merge!)
  153. (define sort sort:sort)
  154. (define sort! sort:sort!)
  155.